home *** CD-ROM | disk | FTP | other *** search
/ Turnbull China Bikeride / Turnbull China Bikeride - Disc 2.iso / STUTTGART / LANG / SCHEME / GNU / SCM4E1 / !Scm / slib / collect < prev    next >
Text File  |  1993-05-14  |  7KB  |  234 lines
  1. ; FILE         "collect.oo"
  2. ; IMPLEMENTS    Sample collection operations
  3. ; AUTHOR        Ken Dickey
  4. ; DATE          1992 September 1
  5. ; LAST UPDATED  1992 September 2
  6. ; NOTES         Expository (optimizations & checks elided).
  7.  
  8. ;               Requires YASOS (Yet Another Scheme Object System).
  9. (require 'yasos)
  10.  
  11. (define-operation (COLLECT:COLLECTION? obj)
  12.  ;; default
  13.   (cond
  14.     ((or (list? obj) (vector? obj) (string? obj)) #t)
  15.     (else #f)
  16. ) )
  17.  
  18. (define (COLLECT:EMPTY? collection) (zero? (yasos:size collection)))
  19.  
  20. (define-operation (COLLECT:GEN-ELTS <collection>) ;; return element generator
  21.   ;; default behavior
  22.   (cond                      ;; see utilities, below, for generators
  23.     ((vector? <collection>) (collect:vector-gen-elts <collection>)) 
  24.     ((list?   <collection>) (collect:list-gen-elts   <collection>))
  25.     ((string? <collection>) (collect:string-gen-elts <collection>))
  26.     (else 
  27.      (slib:error "Operation not supported: GEN-ELTS " (yasos:print obj #f)))
  28. ) )
  29.  
  30. (define-operation (COLLECT:GEN-KEYS collection)
  31.   (if (or (vector? collection) (list? collection) (string? collection))
  32.       (let ( (max+1 (yasos:size collection)) (index 0) )
  33.      (lambda ()
  34.             (cond
  35.           ((< index max+1)
  36.            (set! index (collect:add1 index))
  37.            (collect:sub1 index))
  38.           (else (slib:error "no more keys in generator"))
  39.       ) ) )
  40.       (slib:error "Operation not handled: GEN-KEYS " collection)
  41. ) )
  42.  
  43. (define (COLLECT:DO-ELTS <proc> . <collections>)
  44.   (let ( (max+1 (yasos:size (car <collections>)))
  45.          (generators (map collect:gen-elts <collections>))
  46.        )
  47.     (let loop ( (counter 0) )
  48.        (cond
  49.           ((< counter max+1)
  50.            (apply <proc> (map (lambda (g) (g)) generators))
  51.            (loop (collect:add1 counter))
  52.           )
  53.           (else 'unspecific)  ; done
  54.     )  )
  55. ) )
  56.  
  57. (define (COLLECT:DO-KEYS <proc> . <collections>)
  58.   (let ( (max+1 (yasos:size (car <collections>)))
  59.          (generators (map collect:gen-keys <collections>))
  60.        )
  61.     (let loop ( (counter 0) )
  62.        (cond
  63.           ((< counter max+1)
  64.            (apply <proc> (map (lambda (g) (g)) generators))
  65.            (loop (collect:add1 counter))
  66.           )
  67.           (else 'unspecific)  ; done
  68.     )  )
  69. ) )
  70.  
  71. (define (collect:MAP-ELTS <proc> . <collections>)
  72.   (let ( (max+1 (yasos:size (car <collections>)))
  73.          (generators (map collect:gen-elts <collections>))
  74.          (vec (make-vector (yasos:size (car <collections>))))
  75.        )
  76.     (let loop ( (index 0) )
  77.        (cond
  78.           ((< index max+1)
  79.            (vector-set! vec index (apply <proc> (map (lambda (g) (g)) generators)))
  80.            (loop (collect:add1 index))
  81.           )
  82.           (else vec)  ; done
  83.     )  )
  84. ) )
  85.  
  86. (define (COLLECT:MAP-KEYS <proc> . <collections>)
  87.   (let ( (max+1 (yasos:size (car <collections>)))
  88.          (generators (map collect:gen-keys <collections>))
  89.      (vec (make-vector (yasos:size (car <collections>))))
  90.        )
  91.     (let loop ( (index 0) )
  92.        (cond
  93.           ((< index max+1)
  94.            (vector-set! vec index (apply <proc> (map (lambda (g) (g)) generators)))
  95.            (loop (collect:add1 index))
  96.           )
  97.           (else vec)  ; done
  98.     )  )
  99. ) )
  100.  
  101. (define-operation (COLLECT:FOR-EACH-KEY <collection> <proc>)
  102.    ;; default
  103.    (collect:do-keys <proc> <collection>)  ;; talk about lazy!
  104. )
  105.  
  106. (define-operation (COLLECT:FOR-EACH-ELT <collection> <proc>)
  107.    (collect:do-elts <proc> <collection>)
  108. )
  109.  
  110. (define (COLLECT:REDUCE <proc> <seed> . <collections>)
  111.    (let ( (max+1 (yasos:size (car <collections>)))
  112.           (generators (map collect:gen-elts <collections>))
  113.         )
  114.      (let loop ( (count 0) )
  115.        (cond
  116.           ((< count max+1)
  117.            (set! <seed> 
  118.                  (apply <proc> <seed> (map (lambda (g) (g)) generators)))
  119.            (loop (collect:add1 count))
  120.           )
  121.           (else <seed>)
  122.      ) )
  123. )  )
  124.  
  125.  
  126.  
  127. ;; pred true for every elt?
  128. (define (COLLECT:EVERY? <pred?> . <collections>)
  129.    (let ( (max+1 (yasos:size (car <collections>)))
  130.           (generators (map collect:gen-elts <collections>))
  131.         )
  132.      (let loop ( (count 0) )
  133.        (cond
  134.           ((< count max+1)
  135.            (if (apply <pred?> (map (lambda (g) (g)) generators))
  136.                (loop (collect:add1 count))
  137.                #f)
  138.           )
  139.           (else #t)
  140.      ) )
  141. )  )
  142.  
  143. ;; pred true for any elt?
  144. (define (COLLECT:ANY? <pred?> . <collections>)
  145.    (let ( (max+1 (yasos:size (car <collections>)))
  146.           (generators (map collect:gen-elts <collections>))
  147.         )
  148.      (let loop ( (count 0) )
  149.        (cond
  150.           ((< count max+1)
  151.            (if (apply <pred?> (map (lambda (g) (g)) generators))
  152.                #t
  153.                (loop (collect:add1 count))
  154.           ))
  155.           (else #f)
  156.      ) )
  157. )  )
  158.  
  159.  
  160. ;; MISC UTILITIES
  161.  
  162. (define (COLLECT:ADD1 obj)  (+ obj 1))
  163. (define (COLLECT:SUB1 obj)  (- obj 1))
  164.  
  165. ;; Nota Bene:  list-set! is bogus for element 0
  166.  
  167. (define (COLLECT:LIST-SET! <list> <index> <value>)
  168.  
  169.   (define (set-loop last this idx)
  170.      (cond
  171.         ((zero? idx) 
  172.          (set-cdr! last (cons <value> (cdr this)))
  173.          <list>
  174.         )
  175.         (else (set-loop (cdr last) (cdr this) (collect:sub1 idx)))
  176.   )  )
  177.  
  178.   ;; main
  179.   (if (zero? <index>)
  180.       (cons <value> (cdr <list>))  ;; return value
  181.       (set-loop <list> (cdr <list>) (collect:sub1 <index>)))
  182. )
  183.  
  184. (ADD-SETTER list-ref collect:list-set!)  ; for (setter list-ref)
  185.  
  186.  
  187. ;; generator for list elements
  188. (define (COLLECT:LIST-GEN-ELTS <list>)
  189.   (lambda ()
  190.      (if (null? <list>)
  191.          (slib:error "No more list elements in generator")
  192.          (let ( (elt (car <list>)) )
  193.            (set! <list> (cdr <list>))
  194.            elt))
  195. ) )
  196.  
  197. ;; generator for vector elements
  198. (define (COLLECT:MAKE-VEC-GEN-ELTS <accessor>)
  199.   (lambda (vec)
  200.     (let ( (max+1 (yasos:size vec))
  201.            (index 0)
  202.          )
  203.       (lambda () 
  204.          (cond ((< index max+1)
  205.                 (set! index (collect:add1 index))
  206.                 (<accessor> vec (collect:sub1 index))
  207.                )
  208.                (else #f)
  209.       )  )
  210.   ) )
  211. )
  212.  
  213. (define COLLECT:VECTOR-GEN-ELTS (collect:make-vec-gen-elts vector-ref))
  214.  
  215. (define COLLECT:STRING-GEN-ELTS (collect:make-vec-gen-elts string-ref))
  216.  
  217. ;;; exports:
  218.  
  219. (define COLLECTION? collect:collection?)
  220. (define EMPTY? collect:empty?)
  221. (define gen-keys collect:gen-keys)
  222. (define gen-elts collect:gen-elts)
  223. (define do-elts collect:do-elts)
  224. (define do-keys collect:do-keys)
  225. (define map-elts collect:map-elts)
  226. (define map-keys collect:map-keys)
  227. (define for-each-key collect:for-each-key)
  228. (define for-each-elt collect:for-each-elt)
  229. (define reduce collect:reduce)        ; reduce is also in comlist.scm
  230. (define every? collect:every?)
  231. (define any? collect:any?)
  232.  
  233. ;;                        --- E O F "collect.oo" ---                    ;;
  234.